home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / tsystem.t < prev    next >
Encoding:
Text File  |  1990-06-19  |  4.4 KB  |  128 lines
  1. (herald tsystem (env tsys))
  2.  
  3. ;;;; T Configuration file
  4.  
  5. ;;; ---------- Utilities for systems
  6.  
  7.  
  8. ;;; Fix file names are "<system-name>FIX<edit-number>.T" in the
  9. ;;; system directory.
  10.  
  11. (define (load-fix-file system env)
  12.   (let* ((name (format nil "~a~a~a"
  13.                        (string-downcase! (symbol->string (system-%name system)))
  14.                        (if (experimental?) "xfix" "fix")
  15.                        (link-edit system)))
  16.          (fname (make-filename nil (the-t-system-directory) name nil)))
  17.     (load-quietly-if-present fname env)))
  18.  
  19. ;;; Init file names are "<system-name>_init<edit-number>.T" in the
  20. ;;; system directory.
  21.  
  22. (define (load-init-file system env)
  23.   (let* ((name  (format nil "~ainit" (system-name system)))
  24.          (fname (make-filename nil (the-init-file-directory) name nil)))
  25.     (load-quietly-if-present fname env)))
  26.  
  27. ;;; System initialization stuff
  28.  
  29. ;;; Environment initialization.  Make a "Standard environment,"
  30. ;;; i.e. a fresh environment which has copies of all the "released"
  31. ;;; system bindings in it.
  32.  
  33. (define standard-env (make-empty-locale 'standard-env))
  34. (define standard-syntax-table (env-syntax-table standard-env))
  35.  
  36. (define (initialize-standard-env)
  37.   (export-tsys standard-env)
  38.   (*define standard-env 'standard-syntax-table (env-syntax-table standard-env))
  39.   ;++ flush at 3.1
  40.   (*define standard-env '*standard-syntax-table* (env-syntax-table standard-env))
  41.     ;++ gross hack to prevent crawl from blowing out.  what to do?
  42.     (*lset standard-env '*obj* nil)
  43.     (no-value))
  44.  
  45. ;;; Create a user environment inferior to the standard environment.
  46. ;;; The variable USER-ENV will be defined in the standard
  47. ;;; environment to be the new environment.
  48.  
  49. (define user-env     (make-inferior-locale standard-env 'user-env))
  50.  
  51. (define (initialize-t-system system)
  52.   (set *z?* '#f)
  53.   (set *top-level* standard-top-level)
  54.   (boot-adjust-initial-units)
  55.   (initialize-local-fs)
  56.   (initialize-local-system)
  57.   (initialize-standard-env)
  58.     ;++ temporary grossness
  59.   (*define tvm-env      '*standard-env* standard-env)
  60.   (*define standard-env '*standard-env* standard-env)
  61.   (*define tvm-env      '*scratch-env*  user-env)
  62.   (*define standard-env '*scratch-env*  user-env)
  63.   (load-fix-file system t-implementation-env)
  64.   (set (fancy-symbol-printing?) t)
  65.   (set (repl-env) user-env))
  66.  
  67. (define (re-initialize-t-system system)
  68.   (initialize-local-fs)
  69.   (initialize-local-system)
  70.   (load-fix-file system t-implementation-env)
  71.   (initialize-repl user-env))
  72.  
  73. (define t-system
  74.   (create-system 't (fx/ version-number 10) (fx-rem version-number 10) 6
  75.                  initialize-t-system
  76.                  re-initialize-t-system
  77.                  (lambda (system)
  78.                    (or (load-init-file system user-env)
  79.                        ;++ temp until 3.1
  80.                        (load-quietly-if-present
  81.                         (make-filename nil (the-init-file-directory) 'init nil)
  82.                         user-env)))
  83.                  "Copyright (C) 1988 Yale University"
  84.                  '()))
  85.  
  86. (define (version . arg)
  87.   (if (null? arg) t-system (car arg)))
  88.  
  89. ;;; Utility to load Orbit and Scheme and then suspend the system.
  90.  
  91. (define (load-and-suspend-system filespec . hack)
  92.   (if hack (gc))
  93.   (load '(build oload) t-implementation-env)
  94.   ((*value orbit-env 'load-orbit))
  95.   (let ((suspend-env (make-locale t-implementation-env 'suspend-env)))
  96.     (*define t-implementation-env 'suspend-env suspend-env)
  97.     (load '(link lp_table) suspend-env)
  98.     (case (machine-type (local-machine))
  99.        ((apollo) (load '(link aem68suspend) suspend-env))
  100.        ((sun)    (load '(link sunsuspend) suspend-env))
  101.        ((hp)     (load '(link hpsuspend) suspend-env))
  102.        ((vax/unix)    (load '(link unvaxsuspend) suspend-env)))
  103.      (load '(link suspend) suspend-env)
  104.     (*define t-implementation-env 'system-suspend (*value suspend-env 'system-suspend)))
  105.     (load '(tscheme scheme) t-implementation-env)
  106.   (gc)                  
  107.   (if hack (set (process-global task/area-limit) (area-limit *old-space*)))
  108.   (system-suspend filespec nil))
  109.  
  110.  
  111. ;;; Standard top level, etc.
  112.  
  113. (lset *TOP-LEVEL-GREETING* "T Top level")
  114.  
  115. (define (STANDARD-TOP-LEVEL)
  116. ;++    (reset-stack-guard)
  117.   (set *z?* nil)
  118.   (t-breakpoint *top-level-greeting*))
  119.  
  120. (define (T-RESET)
  121.   (set *top-level* standard-top-level)
  122.   (**reset** nil))
  123.  
  124. ;;; End of basic system initialization sequence.
  125.  
  126. ;;; Control falls from here either into other embedded systems or
  127. ;;; into (*TOP-LEVEL*).
  128.